(in-package :lilu-apropos)

;;;
;;; interactive apropos
;;;

(defparameter *class-options*
  '((:class-name-regex :regex "")
    (:class-package-regex :regex "")
    (:external-p (member :any :yes :no) :yes)
    (:documentation-p (member :any :yes :no) :any)
    (:location-p (member :any :yes :no) :any)))

(defclass class-iapropos (iapropos)
  ()
  (:default-initargs
   :options *class-options*
   :max-result-length 1000
   :sorting-symbol-p t
   :remove-duplicate-p t
   :obj->symbol-fn #'class-name
   :match-object-fn #'%class-iapropos-match-class-p))

(defgeneric class-iapropos-matched-classes (class-iapropos)
  (:method  ((iapropos class-iapropos))
    (with-slots (cached-matched-objects) iapropos
      cached-matched-objects)))

(defun class-iapropos-set-option-values (iapropos &rest args
                                                 &key reset-p class-name-regex
                                                   class-package-regex)
  (declare (ignore class-name-regex class-package-regex))
  (apply #'iapropos-set-option-values iapropos :reset-p reset-p args))

(defmethod iapropos-update-search ((iapropos class-iapropos) changes)
  (labels ((subclasses (class)
             (remove-duplicates (cons class
                                      (mapcan #'subclasses (closer-mop:class-direct-subclasses class))))))
    (iapropos-maching-objects iapropos
                              (subclasses (find-class T)))))

(defun %class-iapropos-match-class-p (iapropos class)
  (with-slots (cached-regexp-scanners option-values) iapropos
    (and
     class
     #+nil(symbol-package (clim:class-name class))
     (when-option-regex (:class-name-regex cached-regexp-scanners)
       (cl-ppcre:scan scanner (string (class-name class))))
     (when-option-regex (:class-package-regex cached-regexp-scanners)
       (when (symbol-package (class-name class))
         (cl-ppcre:scan scanner (string (package-name (symbol-package (class-name class)))))))
     (when-option-yes/no (:external-p option-values)
       (symbol-external-p (class-name class)))
     (when-option-yes/no (:documentation-p option-values)
       (documentation class 'type))
     (when-option-yes/no (:location-p option-values)
       (symbol-location (class-name class) :class)))))

(defmethod iapropos-describe-object ((iapropos class-iapropos) class)
  (append
   (list :name (class-name class)
         :location (let ((loc (symbol-location (class-name class) :class)))
                     (if loc (cons :file loc) :missing))
         :direct-superclasses (mapcar #'class-name (closer-mop:class-direct-superclasses class))
         :direct-subclasses (mapcar #'class-name (closer-mop:class-direct-subclasses class))
         :direct-slots (mapcar #'closer-mop:slot-definition-name (closer-mop:class-direct-slots class))
         :documentation (substitute #\Space #\Newline (documentation class 'type))
         ;;:precedence-list (mapcar #'class-name (closer-mop:class-precedence-list class))
         )))
